home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue28 / subclass / awkward.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-09-05  |  3.4 KB  |  133 lines
  1. unit awkward;
  2. interface
  3. uses
  4. {  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  5.   ExtCtrls;}
  6.  
  7. type
  8.   eAwkwardError = class(exception);
  9.  
  10.   TAwkwardComp = class(TCustomPanel)
  11.   private
  12.    fNewWindowProc : Pointer;  {pointer to our window function}
  13.    fOldWindowProc : Pointer;   {previous window function }
  14.    fTargetHandle : hWnd;
  15.   protected
  16.     { Protected declarations }
  17.   public
  18.     constructor create(aOwner: tcomponent); override;
  19.     destructor destroy; override;
  20.     procedure turnOnSubClassing;
  21.     procedure TurnOffSubClassing;
  22.   published
  23.     property Align;
  24.     property Alignment;
  25.     property BevelInner;
  26.     property BevelOuter;
  27.     property BevelWidth;
  28.     property BorderWidth;
  29.     property BorderStyle;
  30.     property DragCursor;
  31.     property DragMode;
  32.     property Enabled;
  33.     property FullRepaint;
  34.     property Caption;
  35.     property Color;
  36.     property Ctl3D;
  37.     property Font;
  38.     property Locked;
  39.     property ParentColor;
  40.     property ParentCtl3D;
  41.     property ParentFont;
  42.     property ParentShowHint;
  43.     property PopupMenu;
  44.     property ShowHint;
  45.     property TabOrder;
  46.     property TabStop;
  47.     property Visible;
  48.     property OnClick;
  49.     property OnDblClick;
  50.     property OnDragDrop;
  51.     property OnDragOver;
  52.     property OnEndDrag;
  53.     property OnEnter;
  54.     property OnExit;
  55.     property OnMouseDown;
  56.     property OnMouseMove;
  57.     property OnMouseUp;
  58.     property OnResize;
  59.     property OnStartDrag;
  60.   end;
  61.  
  62. function NewFormFunction(handle: hWnd; msg, wParam : Word; lParam : LongInt): LongInt; stdcall;
  63.  
  64. procedure Register;
  65.  
  66. implementation
  67.  
  68. const cMyID : pchar = 'xyz';
  69.  
  70. function NewFormFunction(handle: hWnd; msg, wParam : Word; lParam : LongInt): LongInt; stdcall;
  71. var ThisInstance : longint;
  72. begin
  73.   ThisInstance := getProp(handle, cMyID);
  74.   if TAwkwardComp(ThisInstance).enabled
  75.     then case msg of
  76.      WM_LBUTTONDOWN : TAwkwardComp(ThisInstance).color := clLime;
  77.      WM_RBUTTONDOWN : TAwkwardComp(ThisInstance).color := clWhite;
  78.      end;
  79.  Result := CallWindowProc(TFarProc(TAwkwardComp(ThisInstance).fOldWindowProcAddr),
  80.                            Handle, Msg, wParam, lParam);
  81. end;
  82.  
  83.  
  84. constructor TAwkwardComp.create(aOwner: tcomponent);
  85. begin
  86.   inherited create(aowner);
  87.   fTargetHandle := tform(aOwner).handle;
  88.   bevelInner := bvLowered;
  89.   bevelWidth := 3;
  90.   caption := 'Subclassing off';
  91.   if not TurnOnSubClassing
  92.     then raise eawkwardError('Could not subclass awkard');
  93. end;
  94.  
  95. destructor TAwkwardComp.destroy;
  96. begin
  97.   turnoffSubClassing;
  98.   inherited destroy;
  99. end;
  100.  
  101. function TAwkwardComp.turnOnSubClassing : boolean;
  102. var lresult : longint;
  103. begin
  104.    if SetProp(fTargetHandle, cMyID, longint(self))
  105.      then result := true
  106.      else begin
  107.        result := false;
  108.        exit;
  109.        end;
  110.    fOldWindowProcAddr := GetWindowLong(fTargetHandle, GWL_WNDPROC);
  111.    fNewWindowProc := @NewFormFunction;
  112.    SetLastError(0);  {help file suggests this}
  113.    lResult := SetWindowLong(fTargetHandle, GWL_WNDPROC, LongInt(fNewWindowProc));
  114.    if lResult = 0
  115.      then result := false
  116.      else result := true;
  117.    caption := 'Subclassing on';
  118. end;
  119.  
  120. procedure TAwkwardComp.TurnOffSubClassing;
  121. begin
  122.    SetWindowLong(fTargetHandle, GWL_WNDPROC, longint(fOldWindowProc));
  123.    caption := 'Subclassing off';
  124.    color := clBtnFace;
  125. end;
  126.  
  127. procedure Register;
  128. begin
  129.   RegisterComponents('Samples', [TAwkwardComp]);
  130. end;
  131.  
  132. end.
  133.